home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power Programmierung
/
Power-Programmierung (Tewi)(1994).iso
/
magazine
/
drdobbs
/
1989
/
07
/
floyd.lst
< prev
next >
Wrap
File List
|
1989-06-01
|
13KB
|
664 lines
_TURBO PASCAL WITH OBJECTS_
by Michael Floyd
[LISTING ONE]
program FDemo;
uses Crt, Forms, Sliders;
type
Person = record
Firstname: string[30];
Lastname: string[30];
Address: string[32];
City: string[16];
State: string[2];
Zipcode: Longint;
Counter: array[1..3] of Longint;
Slider: array[1..2] of Integer;
end;
const
Frank: Person = (
Firstname: 'Frank';
Lastname: 'Borland';
Address: '1800 Green Hills Road';
City: 'Scotts Valley';
State: 'CA';
Zipcode: 95066;
Counter: (10, 1000, 65536);
Slider: (85, 25));
var
F: Form;
P: Person;
begin
Color(BackColor);
ClrScr;
Color(ForeColor);
GotoXY(1, 1); ClrEol;
Write(' Turbo Pascal 5.5 Object Oriented Forms Editor');
GotoXY(1, 25); ClrEol;
Write(' F2-Save Esc-Quit');
F.Init(10, 5, 54, 16);
F.Add(New(FStrPtr, Init(3, 2, ' Firstname ', 30)));
F.Add(New(FStrPtr, Init(3, 3, ' Lastname ', 30)));
F.Add(New(FStrPtr, Init(3, 5, ' Address ', 32)));
F.Add(New(FStrPtr, Init(3, 6, ' City ', 16)));
F.Add(New(FStrPtr, Init(25, 6, ' State ', 2)));
F.Add(New(FZipPtr, Init(34, 6, ' Zip ')));
F.Add(New(FIntPtr, Init(3, 8, ' Counter 1 ', 0, 99999999)));
F.Add(New(FIntPtr, Init(22, 8, ' 2 ', 0, 99999999)));
F.Add(New(FIntPtr, Init(33, 8, ' 3 ', 0, 99999999)));
F.Add(New(FSliderPtr, Init(3, 10, ' Slider One ', 0, 100, 5)));
F.Add(New(FSliderPtr, Init(3, 11, ' Slider Two ', 0, 100, 5)));
P := Frank;
F.Put(P);
F.Show;
if F.Edit = CSave then F.Get(P);
F.Done;
NormVideo;
ClrScr;
WriteLn('Resulting Person record:');
WriteLn;
with P do
begin
WriteLn('Firstname: ', Firstname);
WriteLn(' Lastname: ', Lastname);
WriteLn(' Address: ', Address);
WriteLn(' City: ', City);
WriteLn(' State: ', State);
WriteLn(' Zipcode: ', Zipcode);
WriteLn(' Counters: ', Counter[1], ' ', Counter[2], ' ', Counter[3]);
WriteLn(' Sliders: ', Slider[1], ' ', Slider[2]);
end;
end.
[LISTING TWO]
unit Forms;
{$S-}
interface
uses Crt;
const
CSkip = ^@;
CHome = ^A;
CRight = ^D;
CPrev = ^E;
CEnd = ^F;
CDel = ^G;
CBack = ^H;
CSave = ^J;
CUndo = ^R;
CLeft = ^S;
CClear = ^Y;
CNext = ^X;
CQuit = ^[;
type
FStringPtr = ^FString;
FString = string[79];
FieldPtr = ^Field;
Field = object
Next: FieldPtr;
X, Y, Size: Integer;
Title: FStringPtr;
Value: Pointer;
constructor Init(PX, PY, PSize: Integer; PTitle: FString);
destructor Done; virtual;
procedure Beep; virtual;
function Edit: Char; virtual;
function ReadChar: Char; virtual;
procedure Show; virtual;
function Prev: FieldPtr;
end;
FTextPtr = ^FText;
FText = object(Field)
Len: Integer;
constructor Init(PX, PY, PSize: Integer; PTitle: FString;
PLen: Integer);
function Edit: Char; virtual;
procedure GetStr(var S: FString); virtual;
function PutStr(var S: FString): Boolean; virtual;
procedure Show; virtual;
procedure Display(var S: FString);
end;
FStrPtr = ^FStr;
FStr = object(FText)
constructor Init(PX, PY: Integer; PTitle: FString; PLen: Integer);
procedure GetStr(var S: FString); virtual;
function PutStr(var S: FString): Boolean; virtual;
end;
FIntPtr = ^FInt;
FInt = object(FText)
Min, Max: Longint;
constructor Init(PX, PY: Integer; PTitle: FString;
PMin, PMax: Longint);
procedure GetStr(var S: FString); virtual;
function PutStr(var S: FString): Boolean; virtual;
end;
FZipPtr = ^FZip;
FZip = object(FInt)
constructor Init(PX, PY: Integer; PTitle: FString);
procedure GetStr(var S: FString); virtual;
function PutStr(var S: FString): Boolean; virtual;
end;
FormPtr = ^Form;
Form = object
X1, Y1, X2, Y2: Integer;
Last: FieldPtr;
constructor Init(PX1, PY1, PX2, PY2: Integer);
destructor Done; virtual;
function Edit: Char; virtual;
procedure Show; virtual;
procedure Add(P: FieldPtr);
function First: FieldPtr;
procedure Get(var FormBuf);
procedure Put(var FormBuf);
end;
ColorIndex = (BackColor, ForeColor, TitleColor, ValueColor);
procedure Color(C: ColorIndex);
implementation
type
Bytes = array[0..32767] of Byte;
procedure Abstract(Method: String);
begin
WriteLn('Error: Call to abstract method ', Method);
Halt(1);
end;
{ Field }
constructor Field.Init(PX, PY, PSize: Integer; PTitle: FString);
begin
X := PX;
Y := PY;
Size := PSize;
GetMem(Title, Length(PTitle) + 1);
Title^ := PTitle;
GetMem(Value, Size);
FillChar(Value^, Size, 0);
end;
destructor Field.Done;
begin
FreeMem(Value, Size);
FreeMem(Title, Length(Title^) + 1);
end;
procedure Field.Beep;
begin
Sound(500); Delay(25); NoSound;
end;
function Field.Edit: Char;
begin
Abstract('Field.Edit');
end;
function Field.ReadChar: Char;
var
Ch: Char;
begin
Ch := ReadKey;
case Ch of
#0:
case ReadKey of
#15, #72: Ch := CPrev; { Shift-Tab, Up }
#60: Ch := CSave; { F2 }
#71: Ch := CHome; { Home }
#75: Ch := CLeft; { Left }
#77: Ch := CRight; { Right }
#79: Ch := CEnd; { End }
#80: Ch := CNext; { Down }
#83: Ch := CDel; { Del }
else
Ch := CSkip;
end;
#9, #13: Ch := CNext; { Tab, Enter }
end;
ReadChar := Ch;
end;
procedure Field.Show;
begin
Abstract('Field.Show');
end;
function Field.Prev: FieldPtr;
var
P: FieldPtr;
begin
P := @Self;
while P^.Next <> @Self do P := P^.Next;
Prev := P;
end;
{ FText }
constructor FText.Init(PX, PY, PSize: Integer; PTitle: FString;
PLen: Integer);
begin
Field.Init(PX, PY, PSize, PTitle);
Len := PLen;
end;
function FText.Edit: Char;
var
P: Integer;
Ch: Char;
Start, Stop: Boolean;
S: FString;
begin
P := 0;
Start := True;
Stop := False;
GetStr(S);
repeat
Display(S);
GotoXY(X + Length(Title^) + P, Y);
Ch := ReadChar;
case Ch of
#32..#255:
begin
if Start then S := '';
if Length(S) < Len then
begin
Inc(P);
Insert(Ch, S, P);
end;
end;
CLeft: if P > 0 then Dec(P);
CRight: if P < Length(S) then Inc(P) else;
CHome: P := 0;
CEnd: P := Length(S);
CDel: Delete(S, P + 1, 1);
CBack:
if P > 0 then
begin
Delete(S, P, 1);
Dec(P);
end;
CClear:
begin
S := '';
P := 0;
end;
CUndo:
begin
GetStr(S);
P := 0;
end;
CSave, CNext, CPrev:
if PutStr(S) then
begin
Show;
Stop := True;
end else
begin
Beep;
P := 0;
end;
CQuit: Stop := True;
else
Beep;
end;
Start := False;
until Stop;
Edit := Ch;
end;
procedure FText.GetStr(var S: FString);
begin
Abstract('FText.GetStr');
end;
function FText.PutStr(var S: FString): Boolean;
begin
Abstract('FText.PutStr');
end;
procedure FText.Show;
var
S: FString;
begin
GetStr(S);
Display(S);
end;
procedure FText.Display(var S: FString);
begin
GotoXY(X, Y);
Color(TitleColor);
Write(Title^);
Color(ValueColor);
Write(S, '': Len - Length(S));
end;
{ FStr }
constructor FStr.Init(PX, PY: Integer; PTitle: FString; PLen: Integer);
begin
FText.Init(PX, PY, PLen + 1, PTitle, PLen);
end;
procedure FStr.GetStr(var S: FString);
begin
S := FString(Value^);
end;
function FStr.PutStr(var S: FString): Boolean;
begin
FString(Value^) := S;
PutStr := True;
end;
{ FInt }
constructor FInt.Init(PX, PY: Integer; PTitle: FString;
PMin, PMax: Longint);
var
L: Integer;
S: string[15];
begin
Str(PMin, S); L := Length(S);
Str(PMax, S); if L < Length(S) then L := Length(S);
FText.Init(PX, PY, 4, PTitle, L);
Min := PMin;
Max := PMax;
end;
procedure FInt.GetStr(var S: FString);
begin
Str(Longint(Value^), S);
end;
function FInt.PutStr(var S: FString): Boolean;
var
N: Longint;
E: Integer;
begin
Val(S, N, E);
if (E = 0) and (N >= Min) and (N <= Max) then
begin
Longint(Value^) := N;
PutStr := True;
end else PutStr := False;
end;
{ FZip }
constructor FZip.Init(PX, PY: Integer; PTitle: FString);
begin
FInt.Init(PX, PY, PTitle, 0, 99999);
end;
procedure FZip.GetStr(var S: FString);
begin
FInt.GetStr(S);
Insert(Copy('0000', 1, 5 - Length(S)), S, 1);
end;
function FZip.PutStr(var S: FString): Boolean;
begin
PutStr := (Length(S) = 5) and FInt.PutStr(S);
end;
{ Form }
constructor Form.Init(PX1, PY1, PX2, PY2: Integer);
begin
X1 := PX1;
Y1 := PY1;
X2 := PX2;
Y2 := PY2;
Last := nil;
end;
destructor Form.Done;
var
P: FieldPtr;
begin
while Last <> nil do
begin
P := Last^.Next;
if Last = P then Last := nil else Last^.Next := P^.Next;
Dispose(P, Done);
end;
end;
function Form.Edit: Char;
var
P: FieldPtr;
Ch: Char;
begin
Window(X1, Y1, X2, Y2);
P := First;
repeat
Ch := P^.Edit;
case Ch of
CNext: P := P^.Next;
CPrev: P := P^.Prev;
end;
until (Ch = CSave) or (Ch = CQuit);
Edit := Ch;
Window(1, 1, 80, 25);
end;
procedure Form.Show;
var
P: FieldPtr;
begin
Window(X1, Y1, X2, Y2);
Color(ForeColor);
ClrScr;
P := First;
repeat
P^.Show;
P := P^.Next;
until P = First;
Window(1, 1, 80, 25);
end;
procedure Form.Add(P: FieldPtr);
begin
if Last = nil then Last := P else P^.Next := Last^.Next;
Last^.Next := P;
Last := P;
end;
function Form.First: FieldPtr;
begin
First := Last^.Next;
end;
procedure Form.Get(var FormBuf);
var
I: Integer;
P: FieldPtr;
begin
I := 0;
P := First;
repeat
Move(P^.Value^, Bytes(FormBuf)[I], P^.Size);
Inc(I, P^.Size);
P := P^.Next;
until P = First;
end;
procedure Form.Put(var FormBuf);
var
I: Integer;
P: FieldPtr;
begin
I := 0;
P := First;
repeat
Move(Bytes(FormBuf)[I], P^.Value^, P^.Size);
Inc(I, P^.Size);
P := P^.Next;
until P = First;
end;
procedure Color(C: ColorIndex);
type
Palette = array[ColorIndex] of Byte;
const
CP: Palette = ($17, $70, $30, $5E);
MP: Palette = ($07, $70, $70, $07);
begin
if LastMode = CO80 then TextAttr := CP[C] else TextAttr := MP[C];
end;
end.
[LISTING THREE]
unit Sliders;
{$S-}
interface
uses Crt, Forms;
type
FSliderPtr = ^FSlider;
FSlider = object(Field)
Min, Max, Delta: Integer;
constructor Init(PX, PY: Integer; PTitle: FString;
PMin, PMax, PDelta: Integer);
function Edit: Char; virtual;
procedure Show; virtual;
procedure Display(I: Integer);
end;
implementation
constructor FSlider.Init(PX, PY: Integer; PTitle: FString;
PMin, PMax, PDelta: Integer);
begin
Field.Init(PX, PY, 2, PTitle);
Min := PMin;
Max := PMax;
Delta := PDelta;
end;
function FSlider.Edit: Char;
var
I: Integer;
Ch: Char;
Stop: Boolean;
begin
I := Integer(Value^);
Stop := False;
repeat
Display(I);
GotoXY(X + Length(Title^) + 1, Y);
Ch := ReadChar;
case Ch of
CLeft: if I > Min then Dec(I, Delta);
CRight: if I < Max then Inc(I, Delta);
CHome: I := Min;
CEnd: I := Max;
CUndo: I := Integer(Value^);
CSave, CQuit, CNext, CPrev: Stop := True;
else
Beep;
end;
until Stop;
if Ch <> CQuit then Integer(Value^) := I;
Edit := Ch;
end;
procedure FSlider.Show;
begin
Display(Integer(Value^));
end;
procedure FSlider.Display(I: Integer);
var
Steps: Integer;
S: FString;
begin
Steps := (Max - Min) div Delta + 1;
S[0] := Chr(Steps);
FillChar(S[1], Steps, #176);
S[(I - Min) div Delta + 1] := #219;
GotoXY(X, Y);
Color(TitleColor);
Write(Title^);
Color(ValueColor);
Write(' ', Min, ' ', S, ' ', Max, ' ');
end;
end.
Example 1. An object definition
type
ObjectName = object(Ancestor)
variable definitions;
method definitions; {virtual}
end;
Example 2. Code for a basic window
type
Window = object
WindowNo : Integer;
procedure DrawWindow(RowX, ColY, WHeight, WLen : Integer);
procedure RemoveWindow(WindoNo);
end;
Example 3. Code to create specialized windows.
MenuList = string;
MenuBar = object(Window)
procedureDrawWindow(RowX,ColY,WHeight,WLen:Integer;
List:MenuList);
procedure Highlight(Item : Integer);
procedure MenuSelect(Item : Integer);
{ etc... }
end;
Pulldown = object(Window)
{ pulldown methods }
end;